home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / V / lsp / setf.lsp < prev    next >
Lisp/Scheme  |  1991-07-26  |  10KB  |  503 lines

  1. Changes file for /usr/local/src/kcl/lsp/setf.lsp
  2. Created on Thu Jul 25 23:06:53 1991
  3. Usage \n@s[Original text\n@s|Replacement Text\n@s]
  4. See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
  5. for a program to merge change files.  Anything not between
  6. "\n@s[" and  "\n@s]" is a simply a comment.
  7. This file was constructed using emacs and  merge.el
  8. Enhancements Copyright (c) W. Schelter All rights reserved.
  9.    by (Bill Schelter)  wfs@carl.ma.utexas.edu 
  10.  
  11.  
  12. ****Change:(orig (30 30 c))
  13. @s[         `(progn (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
  14.  
  15. @s|         `(eval-when(compile eval load)
  16.                  (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
  17.  
  18. @s]
  19.  
  20.  
  21. ****Change:(orig (45 45 c))
  22. @s[         `(progn (si:putprop ',access-fn ',rest 'setf-lambda)
  23.  
  24. @s|         `(eval-when (compile eval load)
  25.              (si:putprop ',access-fn ',rest 'setf-lambda)
  26.  
  27. @s]
  28.  
  29.  
  30. ****Change:(orig (55 56 c))
  31. @s[(defmacro define-setf-method (access-fn &rest rest)
  32.   `(progn (si:putprop ',access-fn #'(lambda ,@rest) 'setf-method)
  33.  
  34. @s|(defmacro define-setf-method (access-fn &rest rest &aux args env body)
  35.   (multiple-value-setq (args env) 
  36.                (get-&environment (car rest)))
  37.   (setq body (cdr rest))
  38.   (cond (env (setq args (cons env args)))
  39.     (t (setq args (cons (gensym) args))
  40.        (push `(declare (ignore ,(car args))) body)))
  41.   `(eval-when (compile eval load)
  42.           (si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method)
  43.  
  44. @s]
  45.  
  46.  
  47. ****Change:(orig (68 68 c))
  48. @s[(defun get-setf-method (form)
  49.  
  50. @s|(defun get-setf-method (form &optional env)
  51.  
  52. @s]
  53.  
  54.  
  55. ****Change:(orig (70 70 c))
  56. @s[      (get-setf-method-multiple-value form)
  57.  
  58. @s|      (get-setf-method-multiple-value form env)
  59.  
  60. @s]
  61.  
  62.  
  63. ****Change:(orig (78 78 c))
  64. @s[(defun get-setf-method-multiple-value (form)
  65.  
  66. @s|(defun get-setf-method-multiple-value (form &optional env &aux tem)
  67.  
  68. @s]
  69.  
  70.  
  71. ****Change:(orig (83 83 a))
  72. @s[     (error "Cannot get the setf-method of ~S." form))
  73.  
  74. @s|     (error "Cannot get the setf-method of ~S." form))
  75.     ((and env (setq tem (assoc (car form) (second env))))
  76.      (setq tem (macroexpand form env))
  77.      (if (eq form tem) (error "Cannot get setf-method for ~a" form))
  78.      (return-from get-setf-method-multiple-value
  79.               (get-setf-method-multiple-value tem  env)))
  80.  
  81. @s]
  82.  
  83.  
  84. ****Change:(orig (85 86 c))
  85. @s[     (apply (get (car form) 'setf-method) (cdr form)))
  86.     ((get (car form) 'setf-update-fn)
  87.  
  88. @s|     (apply (get (car form) 'setf-method) env (cdr form)))
  89.     ((or (get (car form) 'setf-update-fn)
  90.          (setq tem (get (car form) 'si::structure-access)))
  91.  
  92. @s]
  93.  
  94.  
  95. ****Change:(orig (93 94 c))
  96. @s[               `(,(get (car form) 'setf-update-fn)
  97.              ,@vars ,store)
  98.  
  99. @s|               (cond (tem
  100.                (setf-structure-access (car vars) (car tem)
  101.                           (cdr tem) store))
  102.              (t
  103.                `(,(get (car form) 'setf-update-fn)
  104.                  ,@vars ,store)))
  105.  
  106. @s]
  107.  
  108.  
  109. ****Change:(orig (102 102 a))
  110. @s[        (l (get (car form) 'setf-lambda))
  111.  
  112. @s|        (l (get (car form) 'setf-lambda))
  113.         ;; this looks bogus to me.  What if l is compiled?--wfs
  114.  
  115. @s]
  116.  
  117.  
  118. ****Change:(orig (162 162 c))
  119. @s[(defsetf get (s p &optional d) (v) `(si:putprop ,s ,v ,p))
  120.  
  121. @s|(defsetf get put-aux)
  122. (defmacro put-aux (a b &rest l)
  123.   `(si::sputprop ,a ,b ,(car (last l))))
  124.  
  125. @s]
  126.  
  127.  
  128. ****Change:(orig (181 181 c))
  129. @s[(define-setf-method getf (place indicator &optional default)
  130.  
  131. @s|(define-setf-method getf (&environment env place indicator &optional default)
  132.  
  133. @s]
  134.  
  135.  
  136. ****Change:(orig (183 183 c))
  137. @s[      (get-setf-method place)
  138.  
  139. @s|      (get-setf-method place env)
  140.  
  141. @s]
  142.  
  143.  
  144. ****Change:(orig (197 197 c))
  145. @s[(define-setf-method the (type form)
  146.  
  147. @s|(define-setf-method the (&environment env type form)
  148.  
  149. @s]
  150.  
  151.  
  152. ****Change:(orig (199 199 c))
  153. @s[      (get-setf-method form)
  154.  
  155. @s|      (get-setf-method form env)
  156.  
  157. @s]
  158.  
  159.  
  160. ****Change:(orig (206 206 c))
  161. @s[(define-setf-method apply (fn &rest rest)
  162.  
  163. @s|(define-setf-method apply (&environment env fn &rest rest)
  164.  
  165. @s]
  166.  
  167.  
  168. ****Change:(orig (211 211 c))
  169. @s[      (get-setf-method (cons (cadr fn) rest))
  170.  
  171. @s|      (get-setf-method (cons (cadr fn) rest) env)
  172.  
  173. @s]
  174.  
  175.  
  176. ****Change:(orig (219 219 c))
  177. @s[(define-setf-method apply (fn &rest rest)
  178.  
  179. @s|(define-setf-method apply (&environment env fn &rest rest)
  180.  
  181. @s]
  182.  
  183.  
  184. ****Change:(orig (226 226 c))
  185. @s[      (get-setf-method (cons (cadr fn) rest))
  186.  
  187. @s|      (get-setf-method (cons (cadr fn) rest) env)
  188.  
  189. @s]
  190.  
  191.  
  192. ****Change:(orig (240 240 c))
  193. @s[(define-setf-method char-bit (char name)
  194.  
  195. @s|(define-setf-method char-bit (&environment env char name)
  196.  
  197. @s]
  198.  
  199.  
  200. ****Change:(orig (242 242 c))
  201. @s[      (get-setf-method char)
  202.  
  203. @s|      (get-setf-method char env)
  204.  
  205. @s]
  206.  
  207.  
  208. ****Change:(orig (253 253 c))
  209. @s[(define-setf-method ldb (bytespec int)
  210.  
  211. @s|(define-setf-method ldb (&environment env bytespec int)
  212.  
  213. @s]
  214.  
  215.  
  216. ****Change:(orig (255 255 c))
  217. @s[      (get-setf-method int)
  218.  
  219. @s|      (get-setf-method int env)
  220.  
  221. @s]
  222.  
  223.  
  224. ****Change:(orig (266 266 c))
  225. @s[(define-setf-method mask-field (bytespec int)
  226.  
  227. @s|(define-setf-method mask-field (&environment env bytespec int)
  228.  
  229. @s]
  230.  
  231.  
  232. ****Change:(orig (268 268 c))
  233. @s[      (get-setf-method int)
  234.  
  235. @s|      (get-setf-method int env)
  236.  
  237. @s]
  238.  
  239.  
  240. ****Change:(orig (281 281 c))
  241. @s[(defun setf-expand-1 (place newvalue &aux g)
  242.  
  243. @s|(defun setf-expand-1 (place newvalue env &aux g)
  244.  
  245. @s]
  246.  
  247.  
  248. ****Change:(orig (284 284 c))
  249. @s[          (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue))))
  250.  
  251. @s|          (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env)))
  252.  
  253. @s]
  254.  
  255.  
  256. ****Change:(orig (286 286 a))
  257. @s[        (return-from setf-expand-1 `(setq ,place ,newvalue)))
  258.  
  259. @s|        (return-from setf-expand-1 `(setq ,place ,newvalue)))
  260.   (when (and (consp place)
  261.            (not (or (get (car place) 'setf-lambda)
  262.             (get (car place) 'setf-update-fn))))
  263.       (multiple-value-setq (place g) (macroexpand place env))
  264.       (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
  265.  
  266. @s]
  267.  
  268.  
  269. ****Change:(orig (289 295 c))
  270. @s[  (when (and (symbolp (car place))
  271.              (setq g (get (car place) 'structure-access))
  272.              (get (car place) 'setf-lambda)
  273.              (not (eq (car g) 'list))
  274.  
  275. @s,          `(si:structure-set ,(cadr place) ',(car g) ,(cdr g) ,newvalue)))
  276.  
  277. @s|  (cond ((and (symbolp (car place))
  278.           (setq g (get (car place) 'structure-access)))
  279.      (return-from setf-expand-1
  280.        (setf-structure-access (cadr place) (car g) (cdr g) newvalue))))
  281.          
  282.  
  283. @s]
  284.  
  285.  
  286. ****Change:(orig (297 297 c))
  287. @s[      (get-setf-method place)
  288.  
  289. @s|      (get-setf-method place env)
  290.  
  291. @s]
  292.  
  293.  
  294. ****Change:(orig (304 304 c))
  295. @s[
  296. (defun setf-expand (l)
  297.  
  298. @s|
  299. (defun setf-structure-access (struct type index newvalue)
  300.   (case type
  301.     (list `(si:rplaca-nthcdr ,struct ,index ,newvalue))
  302.     (vector `(si:elt-set ,struct ,index ,newvalue))
  303.     (t `(si::structure-set ,struct ',type ,index ,newvalue))))
  304.  
  305. (defun setf-expand (l env)
  306.  
  307. @s]
  308.  
  309.  
  310. ****Change:(orig (308 309 c))
  311. @s[         (cons (setf-expand-1 (car l) (cadr l))
  312.                (setf-expand (cddr l))))))
  313.  
  314. @s|         (cons (setf-expand-1 (car l) (cadr l) env)
  315.                (setf-expand (cddr l) env)))))
  316.  
  317. @s]
  318.  
  319.  
  320. ****Change:(orig (313 313 c))
  321. @s[(defmacro setf (&rest rest)
  322.  
  323. @s|
  324. (defun setf-helper (rest env)
  325.   (setq rest (cdr rest))
  326.  
  327. @s]
  328.  
  329.  
  330. ****Change:(orig (316 317 c))
  331. @s[        ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest)))
  332.         (t (cons 'progn (setf-expand rest)))))
  333.  
  334. @s|        ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env))
  335.         (t (cons 'progn (setf-expand rest env)))))
  336.  
  337. @s]
  338.  
  339.  
  340. ****Change:(orig (318 318 a))
  341. @s[
  342.  
  343. @s|
  344. ;(setf (macro-function 'setf) 'setf-help)
  345. (si::fset 'setf (cons 'macro (symbol-function 'setf-helper)))
  346.  
  347. @s]
  348.  
  349.  
  350. ****Change:(orig (322 322 c))
  351. @s[(defmacro psetf (&rest rest)
  352.  
  353. @s|(defmacro psetf (&environment env &rest rest)
  354.  
  355. @s]
  356.  
  357.  
  358. ****Change:(orig (326 326 c))
  359. @s[         `(progn ,(setf-expand-1 (car rest) (cadr rest))
  360.  
  361. @s|         `(progn ,(setf-expand-1 (car rest) (cadr rest) env)
  362.  
  363. @s]
  364.  
  365.  
  366. ****Change:(orig (338 338 c))
  367. @s[           (get-setf-method (car r))
  368.  
  369. @s|           (get-setf-method (car r) env)
  370.  
  371. @s]
  372.  
  373.  
  374. ****Change:(orig (349 349 c))
  375. @s[(defmacro shiftf (&rest rest)
  376.  
  377. @s|(defmacro shiftf (&environment env &rest rest )
  378.  
  379. @s]
  380.  
  381.  
  382. ****Change:(orig (367 367 c))
  383. @s[    (get-setf-method (car r))
  384.  
  385. @s|    (get-setf-method (car r) env)
  386.  
  387. @s]
  388.  
  389.  
  390. ****Change:(orig (375 375 c))
  391. @s[(defmacro rotatef (&rest rest)
  392.  
  393. @s|(defmacro rotatef (&environment env &rest rest )
  394.  
  395. @s]
  396.  
  397.  
  398. ****Change:(orig (388 388 c))
  399. @s[              (list (list (car (last stores)) (car access-forms))))
  400.         ,@store-forms))
  401.  
  402. @s|              (list (list (car (last stores)) (car access-forms))))
  403.         ,@store-forms
  404.         nil
  405.         ))
  406.  
  407. @s]
  408.  
  409.  
  410. ****Change:(orig (390 390 c))
  411. @s[    (get-setf-method (car r))
  412.  
  413. @s|    (get-setf-method (car r) env)
  414.  
  415. @s]
  416.  
  417.  
  418. ****Change:(orig (412 412 c))
  419. @s[    `(defmacro ,name (reference . ,lambda-list)
  420.  
  421. @s|    `(defmacro ,name (&environment env reference . ,lambda-list)
  422.  
  423. @s]
  424.  
  425.  
  426. ****Change:(orig (419 419 c))
  427. @s[       (get-setf-method reference)
  428.  
  429. @s|       (get-setf-method reference env)
  430.  
  431. @s]
  432.  
  433.  
  434. ****Change:(orig (429 429 c))
  435. @s[(defmacro remf (place indicator)
  436.  
  437. @s|(defmacro remf (&environment env place indicator)
  438.  
  439. @s]
  440.  
  441.  
  442. ****Change:(orig (431 431 c))
  443. @s[      (get-setf-method place)
  444.  
  445. @s|      (get-setf-method place env)
  446.  
  447. @s]
  448.  
  449.  
  450. ****Change:(orig (441 441 c))
  451. @s[(defmacro push (item place)
  452.  
  453. @s|(defmacro push (&environment env item place)
  454.  
  455. @s]
  456.  
  457.  
  458. ****Change:(orig (445 445 c))
  459. @s[      (get-setf-method place)
  460.  
  461. @s|      (get-setf-method place env)
  462.  
  463. @s]
  464.  
  465.  
  466. ****Change:(orig (451 451 c))
  467. @s[(defmacro pushnew (item place &rest rest)
  468.  
  469. @s|(defmacro pushnew (&environment env item place &rest rest)
  470.   (cond ((symbolp place)
  471.      (return-from pushnew `(setq ,place (adjoin ,item ,place ,@rest)))))
  472.  
  473. @s]
  474.  
  475.  
  476. ****Change:(orig (453 453 c))
  477. @s[      (get-setf-method place)
  478.  
  479. @s|      (get-setf-method place env)
  480.  
  481. @s]
  482.  
  483.  
  484. ****Change:(orig (460 460 c))
  485. @s[       ,store-form)))
  486.  
  487. (defmacro pop (place)
  488.  
  489. @s|       ,store-form)))
  490.  
  491. (defmacro pop (&environment env place)
  492.  
  493. @s]
  494.  
  495.  
  496. ****Change:(orig (468 468 c))
  497. @s[      (get-setf-method place)
  498.  
  499. @s|      (get-setf-method place env)
  500.  
  501. @s]
  502.  
  503.